home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / priorque.scm < prev    next >
Text File  |  1999-04-19  |  4KB  |  137 lines
  1. ;;;; "priorque.scm" priority queues for Scheme.
  2. ;;; Copyright (C) 1992, 1993, 1994, 1995, 1997 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; Algorithm from:
  21. ;;; Introduction to Algorithms by T. Cormen, C. Leiserson, R. Rivest.
  22. ;;; 1989 MIT Press.
  23.  
  24. (require 'record)
  25.  
  26. ;; Record type.
  27. (define heap:rtd (make-record-type "heap" '(array size heap<?)))
  28.  
  29. ;; Constructor.
  30. (define heap:make-heap
  31.   (let ((cstr (record-constructor heap:rtd)))
  32.     (lambda (pred<?)
  33.       (cstr (make-vector 4) 0 pred<?))))
  34.  
  35. ;; Reference an element.
  36. (define heap:ref
  37.   (let ((ra (record-accessor heap:rtd 'array)))
  38.     (lambda (a i)
  39.       (vector-ref (ra a) (+ -1 i)))))
  40.  
  41. ;; Set an element.
  42. (define heap:set!
  43.   (let ((ra (record-accessor heap:rtd 'array)))
  44.     (lambda (a i v)
  45.       (vector-set! (ra a) (+ -1 i) v))))
  46.  
  47. ;; Exchange two elements.
  48. (define heap:exchange
  49.   (let ((aa (record-accessor heap:rtd 'array)))
  50.     (lambda (a i j)
  51.       (set! i (+ -1 i))
  52.       (set! j (+ -1 j))
  53.       (let* ((ra (aa a))
  54.          (tmp (vector-ref ra i)))
  55.     (vector-set! ra i (vector-ref ra j))
  56.     (vector-set! ra j tmp)))))
  57.  
  58.  
  59. ;; Get length.
  60. (define heap:length (record-accessor heap:rtd 'size))
  61.  
  62. (define heap:heap<? (record-accessor heap:rtd 'heap<?))
  63.  
  64. (define heap:set-size!
  65.   (let ((aa (record-accessor heap:rtd 'array))
  66.     (am (record-modifier heap:rtd 'array))
  67.     (sm (record-modifier heap:rtd 'size)))
  68.     (lambda (a s)
  69.       (let ((ra (aa a)))
  70.     (if (> s (vector-length ra))
  71.         (let ((nra (make-vector (+ s (quotient s 2)))))
  72.           (do ((i (+ -1 (vector-length ra)) (+ -1 i)))
  73.           ((negative? i) (am a nra))
  74.         (vector-set! nra i (vector-ref ra i)))))
  75.     (sm a s)))))
  76.  
  77. (define (heap:parent i) (quotient i 2))
  78. (define (heap:left i) (* 2 i))
  79. (define (heap:right i) (+ 1 (* 2 i)))
  80.  
  81. (define (heap:heapify a i)
  82.   (let* ((l (heap:left i))
  83.      (r (heap:right i))
  84.      (largest (if (and (<= l (heap:length a))
  85.                ((heap:heap<? a) (heap:ref a i) (heap:ref a l)))
  86.               l
  87.               i)))
  88.     (cond ((and (<= r (heap:length a))
  89.         ((heap:heap<? a) (heap:ref a largest) (heap:ref a r)))
  90.        (set! largest r)))
  91.     (cond ((not (= largest i))
  92.        (heap:exchange a i largest)
  93.        (heap:heapify a largest)))))
  94.  
  95. (define (heap:insert! a key)
  96.   (define i (+ 1 (heap:length a)))
  97.   (heap:set-size! a i)
  98.   (do ()
  99.       ((not (and (> i 1)
  100.          ((heap:heap<? a) (heap:ref a (heap:parent i)) key))))
  101.     (heap:set! a i (heap:ref a (heap:parent i)))
  102.     (set! i (heap:parent i)))
  103.   (heap:set! a i key))
  104.  
  105. (define (heap:extract-max! a)
  106.   (if (< (heap:length a) 1)
  107.       (slib:error "heap underflow" a))
  108.   (let ((max (heap:ref a 1)))
  109.     (heap:set! a 1 (heap:ref a (heap:length a)))
  110.     (heap:set-size! a (+ -1 (heap:length a)))
  111.     (heap:heapify a 1)
  112.     max))
  113.  
  114. ;;
  115. ;; Externals.
  116. ;;
  117. (define make-heap heap:make-heap)
  118. (define heap-insert! heap:insert!)
  119. (define heap-extract-max! heap:extract-max!)
  120. (define heap-length heap:length)
  121.  
  122. (define (heap:test)
  123.   (require 'debug)
  124.   (let ((heap #f))
  125.     (set! heap (make-heap char>?))
  126.     (heap-insert! heap #\A)
  127.     (heap-insert! heap #\Z)
  128.     (heap-insert! heap #\G)
  129.     (heap-insert! heap #\B)
  130.     (heap-insert! heap #\G)
  131.     (heap-insert! heap #\Q)
  132.     (heap-insert! heap #\S)
  133.     (heap-insert! heap #\R)
  134.     (do ((i 7 (+ -1 i)))
  135.     ((negative? i))
  136.       (write (heap-extract-max! heap)) (newline))))
  137.